home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / block-io-mcl.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  8.5 KB  |  225 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: ccl -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; block-io-mcl.lisp
  6. ;; low-level block I/O - MCL version.
  7. ;;
  8. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  9. ;; Permission is given to use, copy, and modify this software provided
  10. ;; that this copyright notice is attached to all derivative works.
  11. ;; This software is provided "as is". Apple makes no warranty or
  12. ;; representation, either express or implied, with respect to this software,
  13. ;; its quality, accuracy, merchantability, or fitness for a particular
  14. ;; purpose.
  15. ;;
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;
  19. ;; Modification history
  20. ;;
  21. ;; ------------  0.5
  22. ;; 03/05/92 bill New file
  23. ;;
  24.  
  25. (in-package :ccl)
  26.  
  27. (export '(stream-read-bytes stream-write-bytes set-minimum-file-length))
  28.  
  29. (provide :block-io)
  30.  
  31. ;; (stream-read-bytes stream address vector offset length)
  32. ;;   read length bytes into vector at offset from stream at address.
  33. ;;
  34. ;; (stream-write-bytes stream address vector offset length)
  35. ;;   write length bytes from stream at address into vector at offset.
  36. ;;   Extend the length of the file if necessary.
  37. ;;
  38. ;; (set-minimum-file-length stream length)
  39. ;;   Set the file length of stream to >= length.
  40. ;;
  41. ;; This implementation only supports vectors of type
  42. ;; (array (unsigned-byte 8)), (array (signed-byte 8)), or simple-string
  43.  
  44. (eval-when (eval compile)
  45.   (require 'lapmacros)
  46.   (require 'lispequ)
  47.  
  48. ;structure of fblock
  49. ;from "ccl:level-1;l1-sysio.lisp"
  50.  
  51. (let ((*warn-if-redefine* nil))
  52.  
  53. (def-accessors (fblock) %svref
  54.   nil                                   ; 'fblock
  55.   fblock.pb                             ; a parameter block; nil if closed.
  56.   fblock.lastchar                       ; untyi char or nil
  57.   fblock.dirty                          ; non-nil when dirty
  58.   fblock.buffer                         ; macptr to buffer; nil when closed
  59.   fblock.bufvec                         ; buffer vector; nil when closed
  60.   fblock.bufsize                        ; size (in 8-bit bytes) of buffer
  61.   fblock.bufidx                         ; index of next element to read/write
  62.   fblock.bufcount                       ; # of elements in buffer
  63.   fblock.filepos                        ; 8-bit position at last read/write
  64.   fblock.fileeof                        ; file's logical eof.
  65.   fblock.stream                         ; backptr to file stream
  66.   fblock.element-type                   ; typespec
  67.   fblock.nbits-per-element              ; # of bits per element
  68.   fblock.elements-per-buffer            ; 512 or whatever
  69.   fblock.minval                         ; minimum value of element type or nil: < 0 
  70.   fblock.maxval                         ; maximum value or nil
  71.   fblock.element-bit-offset             ; for non-arefable n-bit elements
  72. )
  73.  
  74. ) ; end of let
  75.  
  76. ) ; end of eval-when
  77.  
  78. ; Read length bytes into array at offset from stream at address.
  79. ; Array must be a simple (byte 8) array.
  80. ; stream must be an input stream for 8 bit elements.
  81. (defmethod stream-read-bytes ((stream input-file-stream)
  82.                               address array offset length)
  83.   (%fread-bytes (slot-value stream 'fblock)
  84.                 (require-type address 'fixnum)
  85.                 array
  86.                 (require-type offset 'fixnum)
  87.                 (require-type length 'fixnum)))
  88.  
  89. (defun %fread-bytes (fblock address array offset length)
  90.   (declare (fixnum address offset length))
  91.   (unless (eql 8 (fblock.nbits-per-element fblock))
  92.     (error "%fread-bytes only implemented for 8-bit bytes"))
  93.   (unless (>= (length array) (the fixnum (+ offset length)))
  94.     (error "array too small"))
  95.   (when (lap-inline (array)
  96.           (move.l arg_z atemp0)
  97.           (movereg arg_z acc)
  98.           (if# (and (ne (dtagp arg_z $t_vector))
  99.                     (or (eq (progn (move.b (atemp0 $v_subtype) da)
  100.                                    (cmp.b ($ $v_ubytev) da)))
  101.                         (eq (cmp.b ($ $v_sbytev) da))
  102.                         (eq (cmp.b ($ $v_sstr) da))))
  103.             (move.l nilreg acc)))
  104.     (%badarg array '(or (array (signed-byte 8))
  105.                      (array (unsigned-byte 8))
  106.                      simple-string)))
  107.   (let ((max-length (- (%fsize fblock) address)))
  108.     (declare (fixnum max-length))
  109.     (if (< max-length length) (setq length max-length))
  110.     (if (< length 0) (setq length 0)))
  111.   (let ((bytes length)
  112.         (bufvec (fblock.bufvec fblock)))
  113.     (declare (fixnum bytes))
  114.     (loop
  115.       (when (<= length 0) (return bytes))
  116.       (%fpos fblock address)
  117.       (let* ((vec-index (- address (the fixnum (fblock.filepos fblock))))
  118.              (vec-left (- (the fixnum (fblock.bufcount fblock)) vec-index)))
  119.         (declare (fixnum vec-index vec-left))
  120. ;        (print-db vec-index vec-left)
  121.         (if (> vec-left length) (setq vec-left length))
  122.         (lap-inline ()
  123.           (:variable bufvec array offset vec-index vec-left)
  124.           (move.l (varg bufvec) atemp0)
  125.           (move.l (varg vec-index) acc)
  126.           (getint acc)
  127.           (lea (atemp0 acc $v_data) atemp0)
  128.           (move.l (varg array) atemp1)
  129.           (move.l (varg offset) acc)
  130.           (getint acc)
  131.           (lea (atemp1 acc $v_data) atemp1)
  132.           (move.l (varg vec-left) acc)
  133.           (getint acc)
  134.           (dbfloop acc (move.b atemp0@+ atemp1@+)))
  135.       (incf address vec-left)
  136.       (decf length vec-left)))))
  137.  
  138. ; same, but other direction
  139. (defmethod stream-write-bytes ((stream output-file-stream)
  140.                                address array offset length)
  141.   (%fwrite-bytes (slot-value stream 'fblock)
  142.                  (require-type address 'fixnum)
  143.                  array
  144.                  (require-type offset 'fixnum)
  145.                  (require-type length 'fixnum)))
  146.  
  147. (defun %fwrite-bytes (fblock address array offset length)
  148.   (declare (fixnum address offset length))
  149.   (unless (eql 8 (fblock.nbits-per-element fblock))
  150.     (error "%fwrite-bytes only implemented for 8-bit bytes"))
  151.   (unless (>= (length array) (the fixnum (+ offset length)))
  152.     (error "array too small"))
  153.   (when (lap-inline (array)
  154.           (move.l arg_z atemp0)
  155.           (movereg arg_z acc)
  156.           (if# (and (ne (dtagp arg_z $t_vector))
  157.                     (or (eq (progn (move.b (atemp0 $v_subtype) da)
  158.                                    (cmp.b ($ $v_ubytev) da)))
  159.                         (eq (cmp.b ($ $v_sbytev) da))
  160.                         (eq (cmp.b ($ $v_sstr) da))))
  161.             (move.l nilreg acc)))
  162.     (%badarg array '(or (array (signed-byte 8))
  163.                      (array (unsigned-byte 8))
  164.                      simple-string)))
  165.   (let ((min-size (+ address length)))
  166.     (declare (fixnum min-size))
  167.     (when (> min-size (%fsize fblock))
  168.       (%fsize fblock min-size)))
  169.   (let ((bytes length)
  170.         (bufvec (fblock.bufvec fblock)))
  171.     (declare (fixnum bytes))
  172.     (loop
  173.       (when (<= length 0) (return bytes))
  174.       (%fpos fblock address)
  175.       (let* ((vec-index (- address (the fixnum (fblock.filepos fblock))))
  176.              (vec-left (- (the fixnum (fblock.elements-per-buffer fblock))
  177.                           vec-index)))
  178.         (declare (fixnum vec-index vec-left))
  179.         (if (> vec-left length) (setq vec-left length))
  180.         (lap-inline ()
  181.           (:variable bufvec array offset vec-index vec-left)
  182.           (move.l (varg bufvec) atemp0)
  183.           (move.l (varg vec-index) acc)
  184.           (getint acc)
  185.           (lea (atemp0 acc $v_data) atemp0)
  186.           (move.l (varg array) atemp1)
  187.           (move.l (varg offset) acc)
  188.           (getint acc)
  189.           (lea (atemp1 acc $v_data) atemp1)
  190.           (move.l (varg vec-left) acc)
  191.           (getint acc)
  192.           (dbfloop acc (move.b atemp1@+ atemp0@+)))
  193.         (let ((index (+ vec-index vec-left))
  194.               (bufcount (fblock.bufcount fblock)))
  195.           (declare (fixnum index bufcount))
  196.           (if (> index bufcount)
  197.             (setf (fblock.bufcount fblock) index))
  198.           (setf (fblock.bufidx fblock) index
  199.                 (fblock.dirty fblock) t))
  200.         (incf address vec-left)
  201.         (decf length vec-left)))))
  202.  
  203. (defun set-minimum-file-length (stream length)
  204.   (file-length stream length))
  205.  
  206. #|
  207. (setq s (open "temp.lisp" :direction :io :if-exists :overwrite))
  208.  
  209. (defun r (address length)
  210.   (declare (special s))
  211.   (let ((v (make-string length)))
  212.     (let ((real-length (stream-read-bytes s address v 0 length)))
  213.       (if (eql length real-length)
  214.         (values v length)
  215.         (let ((res (make-string real-length)))
  216.           (dotimes (i real-length)
  217.             (setf (aref res i) (aref v i)))
  218.           (values res real-length))))))
  219.  
  220. (defun w (string address &optional
  221.                  (offset 0) (length (- (length string) offset)))
  222.   (declare (special s))
  223.   (stream-write-bytes s address string offset length))
  224.  
  225. |#